home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb34.arc / DIRARC.PAS < prev    next >
Pascal/Delphi Source File  |  1986-04-25  |  11KB  |  391 lines

  1. program darc;
  2. {$R-$U-$C-$K-}
  3. {
  4.   Program:      DIRARC.PAS
  5.   Version:      1.0
  6.   Date:         1/4/86
  7.   Author:       Steve Fox, Albuquerque ROS (505)299-5974
  8.   Credits:      Based heavily on DARC.PAS and intended as a companion to
  9.                 that program.
  10.   Description:  Display the directory of an archive created by version 4.30
  11.                 or earlier of the ARC utility (copyright 1985 by System
  12.                 Enhancement Associates) in a format similar to the "v"erbose
  13.                 command.  Some minor differences in the computed values of the
  14.                 stowage factors may be noted due to rounding.
  15.   Language:     Turbo Pascal Version 3.0 and later (either MS-DOS or CP/M).
  16.   Usage:        DIRARC arcname
  17.                 where arcname is the path/file name of the archive file.  If
  18.                 the file extent is omitted, .ARC is assumed.
  19. }
  20. const
  21.   BLOCKSIZE = 128;
  22.   arcmarc   = 26;                      { special archive marker }
  23.   arcver    = 6;                       { archive header version code }
  24.   strlen    = 80;                      { standard string length }
  25.   fnlen     = 12;                      { file name length - 1 }
  26. type
  27.   long      = record                   { used to simulate long (4 byte) integers }
  28.                 l, h : integer
  29.               end;
  30.   Str10     = string[10];
  31.   StrStd    = string[strlen];
  32.   fntype    = array [0..fnlen] of char;
  33.   buftype   = array [1..BLOCKSIZE] of byte;
  34.   heads     = record
  35.                 name   : fntype;
  36.                 size   : long;
  37.                 date   : integer;
  38.                 time   : integer;
  39.                 crc    : integer;
  40.                 length : long
  41.               end;
  42.   hexvalue  = string[2];
  43. var
  44.   endfile   : boolean;
  45.   hdrver    : byte;
  46.   arcptr    : integer;
  47.   arcname,
  48.   extname   : StrStd;
  49.   arcbuf    : buftype;
  50.   arcfile   : file;
  51.  
  52. function hexval(bt : byte) : hexvalue;
  53. { Convert 8 bit value to hex }
  54.   const
  55.     hexcnv : array[0..15] of char = '0123456789ABCDEF';
  56.   begin
  57.     hexval := hexcnv[bt shr 4] + hexcnv[bt and $0F]
  58.   end;
  59.  
  60. function pad(stg : StrStd; i : integer) : StrStd;
  61. { Pad string with spaces to length of i }
  62.   var
  63.     j : integer;
  64.   begin
  65.     j := length(stg);
  66.     FillChar(stg[succ(j)], i - j, ' ');
  67.     stg[0] := chr(i);
  68.     pad := stg
  69.   end;
  70.  
  71. function intstr(n, w: integer): Str10;
  72. { Return a string value (width 'w')for the input integer ('n') }
  73.   var
  74.     stg: Str10;
  75.   begin
  76.     str(n:w, stg);
  77.     intstr := stg
  78.   end;
  79.  
  80. procedure abort(msg : StrStd);
  81. { terminate the program with an error message }
  82.   begin
  83.     writeln('ABORT: ', msg);
  84.     halt
  85.   end;
  86.  
  87. function fn_to_str(var fn : fntype) : StrStd;
  88. { convert strings from C format (trailing 0) to
  89.   Turbo Pascal format (leading length byte). }
  90.   var
  91.     s : StrStd;
  92.     i : integer;
  93.   begin
  94.     s := '';
  95.     i := 0;
  96.     while fn[i] <> #0 do
  97.       begin
  98.         s := s + fn[i];
  99.         i := succ(i)
  100.       end;
  101.     fn_to_str := s
  102.   end;
  103.  
  104. function unsigned_to_real(u : integer) : real;
  105. { convert unsigned integer to real }
  106. { note: INT is a function that returns a REAL!!!}
  107.   begin
  108.     if u >= 0
  109.       then unsigned_to_real := Int(u)
  110.     else if u = $8000
  111.       then unsigned_to_real := 32768.0
  112.       else unsigned_to_real := 65536.0 + u
  113.   end;
  114.  
  115. function long_to_real(l : long) : real;
  116. { convert long integer to a real }
  117. { note: INT is a function that returns a REAL!!! }
  118.   const
  119.     rcon = 65536.0;
  120.   var
  121.     r : real;
  122.     s : (POS, NEG);
  123.   begin
  124.     if l.h >= 0
  125.       then
  126.         begin
  127.           r := Int(l.h) * rcon;
  128.           s := POS
  129.         end
  130.       else
  131.         begin
  132.           s := NEG;
  133.           if l.h = $8000
  134.             then r := rcon * rcon
  135.             else r := Int(-l.h) * rcon
  136.         end;
  137.     r := r + unsigned_to_real(l.l);
  138.     if s = NEG
  139.       then long_to_real := -r
  140.       else long_to_real := r
  141.   end;
  142.  
  143. procedure Read_Block;
  144. { read a block from the archive file }
  145.   begin
  146.     if EOF(arcfile)
  147.       then endfile := TRUE
  148.       else BlockRead(arcfile, arcbuf, 1);
  149.     arcptr := 1
  150.   end;
  151.  
  152. function get_arc : byte;
  153. { read 1 character from the archive file }
  154.   begin
  155.     if endfile
  156.       then get_arc := 0
  157.       else
  158.         begin
  159.           get_arc := arcbuf[arcptr];
  160.           if arcptr = BLOCKSIZE
  161.             then Read_Block
  162.             else arcptr := succ(arcptr)
  163.         end
  164.   end;
  165.  
  166. procedure fread(var buf; reclen : integer);
  167. { read a record from the archive file }
  168.   var
  169.     i : integer;
  170.     b : array [1..strlen] of byte absolute buf;
  171.   begin
  172.     for i := 1 to reclen
  173.       do b[i] := get_arc
  174.   end;
  175.  
  176. function readhdr(var hdr : heads) : boolean;
  177. { read a file header from the archive file }
  178. { FALSE = eof found; TRUE = header found }
  179.   var
  180.     try  : integer;
  181.     name : fntype;
  182.   begin
  183.     try := 10;
  184.     if endfile
  185.       then
  186.         begin
  187.           readhdr := FALSE;
  188.           exit
  189.         end;
  190.     while get_arc <> arcmarc do
  191.       begin
  192.         if try = 0
  193.           then abort(arcname + ' is not an archive');
  194.         try := pred(try);
  195.         writeln(arcname, ' is not an archive, or is out of sync');
  196.         if endfile
  197.           then abort('Archive length error')
  198.       end;
  199.  
  200.     hdrver := get_arc;
  201.     if hdrver < 0
  202.       then abort('Invalid header in archive ' + arcname);
  203.     if hdrver = 0
  204.       then
  205.         begin                          { special end of file marker }
  206.           readhdr := FALSE;
  207.           exit
  208.       end;
  209.     if hdrver > arcver
  210.       then
  211.         begin
  212.           fread(name, fnlen);
  213.           writeln('Cannot handle file ', fn_to_str(name), ' in archive ',
  214.             arcname);
  215.           writeln('You need a newer version of this program.');
  216.           halt
  217.         end;
  218.  
  219.     if hdrver = 1
  220.       then
  221.         begin
  222.           fread(hdr, sizeof(heads) - sizeof(long));
  223.           hdrver := 2;
  224.           hdr.length := hdr.size
  225.         end
  226.       else fread(hdr, sizeof(heads));
  227.  
  228.     readhdr := TRUE
  229.   end;
  230.  
  231. procedure PrintHeading;
  232.   begin
  233.     writeln;
  234.     writeln('Turbo Pascal DIRARC Utility');
  235.     writeln('Version 1.0, 1/4/86');
  236.     writeln
  237.   end;
  238.  
  239. procedure GetArcName;
  240. { get the name of the archive file }
  241.   var
  242.     i : integer;
  243.   begin
  244.     if ParamCount = 1
  245.       then arcname := ParamStr(1)
  246.     else if ParamCount > 1
  247.       then abort('Too many parameters')
  248.       else
  249.         begin
  250.           write('Enter archive filename: ');
  251.           readln(arcname);
  252.           if arcname = ''
  253.             then abort('No file name entered');
  254.           writeln;
  255.           writeln
  256.         end;
  257.     for i := 1 to length(arcname) do
  258.       arcname[i] := UpCase(arcname[i]);
  259.     if pos('.', arcname) = 0
  260.       then arcname := arcname + '.ARC'
  261.   end;
  262.  
  263. function int_time(time : integer) : StrStd;
  264. { Convert integer format time to printable string }
  265.   var
  266.     ampm : char;
  267.     hour, minute : integer;
  268.     line : string[6];
  269.   begin
  270.     minute := (time shr 5) and $003F;
  271.     hour   := time shr 11;
  272.     if hour > 12
  273.       then
  274.         begin
  275.           hour := hour - 12;
  276.           ampm := 'p'
  277.         end
  278.       else ampm := 'a';
  279.     if hour = 0
  280.       then hour := 12;
  281.     line := intstr(hour, 2) + ':' + intstr(minute, 2) + ampm;
  282.     if line[4] = ' '
  283.       then line[4] := '0';
  284.     int_time := line
  285.   end;
  286.  
  287. function int_date(date : integer) : StrStd;
  288. { Convert standard integer format date to printable string }
  289.   const
  290.     month_name : array[1..12] of string[3] =
  291.       ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  292.   var
  293.     day, month, year : integer;
  294.     line : string[9];
  295.   begin
  296.     day   := date and $001F;
  297.     month := (date shr 5) and $000F;
  298.     year  := (date shr 9 + 80) mod 100;
  299.     if month in [1..12]
  300.       then line := month_name[month]
  301.       else line := '   ';
  302.     line := intstr(day, 2) + ' ' + line + ' ' + intstr(year, 2);
  303.     if line[8] = ' '
  304.       then line[8] := '0';
  305.     int_date := line
  306.   end;
  307.  
  308. procedure open_arc;
  309. { open the archive file for input processing }
  310.   begin
  311.     {$I-} assign(arcfile, arcname); {$I+}
  312.     if IOresult <> 0
  313.       then abort('Cannot open archive file.');
  314.     {$I-} reset(arcfile); {$I+}
  315.     if IOresult <> 0
  316.       then abort('Cannot open archive file.');
  317.     endfile := FALSE;
  318.     Read_Block
  319.   end;
  320.  
  321. procedure close_arc;
  322. { close the archive file }
  323.   begin
  324.     close(arcfile)
  325.   end;
  326.  
  327. procedure directory;
  328.   const
  329.     stowage : array[1..6] of string[8] =
  330.       ('????????', '   --   ', ' Packed ', 'Squeezed', '????????', 'Crunched');
  331.   var
  332.     i, total_files, sf : integer;
  333.     size_org, size_now, next_ptr, total_length, total_size : real;
  334.     stg_time, stg_date : Str10;
  335.     hdr : heads;
  336.   begin
  337.     writeln('Name          Length    Stowage    SF   Size now  Date       Time    CRC');
  338.     writeln('============  ========  ========  ====  ========  =========  ======  ====');
  339.     total_files  := 0;
  340.     next_ptr     := 0.0;
  341.     total_size   := 0.0;
  342.     total_length := 0.0;
  343.     open_arc;
  344.     while readhdr(hdr) do
  345.       begin
  346.         extname := fn_to_str(hdr.name);
  347.         total_files := succ(total_files);
  348.         size_org := long_to_real(hdr.length);
  349.         total_length := total_length + size_org;
  350.         size_now := long_to_real(hdr.size);
  351.         total_size := total_size + size_now;
  352.         stg_time := int_time(hdr.time);
  353.         stg_date := int_date(hdr.date);
  354.         if size_org > 0
  355.           then sf := round(100.0 * (size_org - size_now) / size_org)
  356.           else sf := 0;
  357.         writeln(
  358.           pad(extname, 12),
  359.           size_org:10:0,
  360.           stowage[hdrver]:10,
  361.           sf:5, '%',
  362.           size_now:10:0,
  363.           stg_date:11,
  364.           stg_time:8,
  365.           hexval(hi(hdr.crc)):4, hexval(lo(hdr.crc)):2);
  366.         next_ptr := next_ptr + size_now + 29.0;
  367.         i := trunc(next_ptr / 128.0);
  368.         seek(arcfile, i);
  369.         Read_Block;
  370.         arcptr := succ(round(next_ptr - 128.0 * i))
  371.       end;
  372.     close_arc;
  373.     writeln('        ====  ========            ====  ========');
  374.     if total_length > 0
  375.       then sf := round(100.0 * (total_length - total_size) / total_length)
  376.       else sf := 0;
  377.     writeln(
  378.       'Total',
  379.       total_files:7,
  380.       total_length:10:0,
  381.       ' ':10,
  382.       sf:5, '%',
  383.       total_size:10:0)
  384.   end;
  385.  
  386. begin
  387.   PrintHeading;                        { print a heading }
  388.   GetArcName;                          { get the archive file name }
  389.   directory
  390. end.
  391.